Cream of the Crop 20/Cream of the Crop 20 (Terry Blount) (1996).iso/os2/xdsn217.zip/SAMPLES/MAND/mand.mod

Text File | 1996-07-09 | 20KB | 690 lines

(**********************************************************************)
(*                                                                    *)
(*                     xTech Development System                       *)
(*                    Native XDS-x86 OS/2 Edition                     *)
(*                                                                    *)
(*      Mandelbrodt Set Explorer for OS/2 Presentation Manager        *)
(*                                                                    *)
(*  Mand.mod - main source file                                       *)
(*                                                                    *)
(*  Make:                                                             *)
(*      xc =p mand.prj                                                *)
(*      rc mand.res mand.exe                                          *)
(*                                                                    *)
(*  Control:                                                          *)
(*      Left mouse button - 2x magnification                          *)
(*      Right mouse button - 4x magnification                         *)
(*                                                                    *)
(*  Copyright (C) 1996 xTech ltd                                      *)
(*                                                                    *)
(**********************************************************************)

MODULE Mand;

IMPORT FormStr, Storage, SYSTEM;
IMPORT O:=OS2;
FROM SYSTEM IMPORT ADR, ADDRESS, CAST, CARD8, REF, FILL;

CONST MAINCLASSNAME = "MandelbrodtSet";

      RES_MAIN      = 17;

      REFRESH_ITEM  = 17;
      COPY_ITEM     = 2;
      BACK_ITEM     = 3;
      FORWARD_ITEM  = 4;

      MSG_UPDATE    = O.WM_USER+1000;
      MSG_DONE      = O.WM_USER+1001;
      MSG_MENUSTATE = O.WM_USER+1002;
      --MSG_TITLE     = O.WM_USER+1003;
      MSG_BUILD     = O.WM_USER+1004;

VAR  hAB                     :O.HAB;
     hMainFrame, hMainClient :O.HWND;

     tidCntThread            :O.TID;
     nRecalc                 :INTEGER;
     perc, prevperc          :CARDINAL;
     ulTimerId               :CARDINAL;

(** Macros from OS2.H are expected  **)

PROCEDURE CARD2FROMMP (mp: O.MPARAM): CARDINAL;
BEGIN
  RETURN VAL (CARDINAL, CAST(SYSTEM.CARD16, SYSTEM.SHIFT(CAST(BITSET,mp),-16)) );
END CARD2FROMMP;

PROCEDURE CARD1FROMMP(mp: O.MPARAM): CARDINAL;
BEGIN
  RETURN VAL (CARDINAL, CAST (SYSTEM.CARD16, mp) );
END CARD1FROMMP;

PROCEDURE CARDFROMMP(mp: O.MPARAM): CARDINAL;
BEGIN
  RETURN CAST (CARDINAL, mp );
END CARDFROMMP;

PROCEDURE MPFROMCARD(c :CARDINAL) :O.MPARAM;
BEGIN
  RETURN CAST(O.MPARAM, c);
END MPFROMCARD;

PROCEDURE MPFROM2CARD(c1,c2 :CARDINAL) :O.MPARAM;
BEGIN
  RETURN
  CAST(O.MPARAM,
       CAST(SYSTEM.CARD32, SYSTEM.SHIFT(BITSET(c2), 16))+
       CAST(SYSTEM.CARD16, c1)
      );
END MPFROM2CARD;

PROCEDURE MPFROMP(p :ADDRESS) :O.MPARAM;
BEGIN
  RETURN CAST(O.MPARAM, p);
END MPFROMP;


PROCEDURE MyEnableMenuItem(hwndMenu :O.HWND; usId :CARDINAL; fEnable :BOOLEAN);
VAR c :CARDINAL;
BEGIN
  IF fEnable
   THEN c:= 0;
   ELSE c:= O.MIA_DISABLED;
  END;

  O.WinSendMsg(hwndMenu, O.MM_SETITEMATTR,
               MPFROM2CARD(usId, 1),
               MPFROM2CARD(O.MIA_DISABLED, c)
              );

END MyEnableMenuItem;




(*-------------------------- Abstract data types -----------------------------*)

(** Bit-map info structure **)

MODULE BI;

FROM O      IMPORT BITMAPINFO2, PBITMAPINFO2, RGB2;
IMPORT ADR, ADDRESS, CARD8, REF, FILL;

EXPORT QUALIFIED Setsz, bi;


TYPE  BIS = RECORD
        h   : BITMAPINFO2;
        clr : ARRAY [1..255] OF RGB2;
      END;

VAR   bi      :BIS;
      i       :CARDINAL;

PROCEDURE Setsz(cx, cy :CARDINAL);
BEGIN
  bi.h.cx := cx;
  bi.h.cy := cy;
END Setsz;

-- Type constructor

BEGIN

  FILL(ADR(bi), 0, SIZE(BIS) );
  bi.h.cbFix     := SIZE(BITMAPINFO2)-SIZE(RGB2);
  bi.h.cPlanes   := 1;
  bi.h.cBitCount := 8;

  FOR i:=0 TO 254 DO
   bi.clr[i].bRed     := VAL (CARD8, i MOD 16 * 16);
   bi.clr[i].bGreen   := VAL (CARD8, (i DIV 8 MOD 8) * 32);
   bi.clr[i].bBlue    := VAL (CARD8, (i DIV 32) * 32);
  END;

END BI;

(** Mandel info data type **)

MODULE MI;

FROM Storage IMPORT ALLOCATE, DEALLOCATE;
FROM O IMPORT DosFreeMem;
IMPORT CARD8, ADDRESS;

EXPORT MANDINFO, PMANDINFO, MINew, MIDel;

CONST START_X0 = -3.0;
      START_Y0 = -2.3;
      START_X1 =  2.0;
      START_Y1 =  2.2;

TYPE
      MANDINFO = RECORD
                  MX0,MY0,MX1,MY1 :LONGREAL; -- Mandelbrodt parms
                  Bcx,Bcy         :CARDINAL; -- current bit-map sizes (=curr client rgn sizes)
                  pMBitmap        :ADDRESS;  -- bit-map image
                 END;

      PMANDINFO = POINTER TO MANDINFO;


PROCEDURE MINew(VAR pminfo :PMANDINFO; pmsrc :PMANDINFO);
BEGIN
  ALLOCATE( pminfo, SIZE(MANDINFO) );

  IF pmsrc=NIL
   THEN pminfo^.MX0 := START_X0;
        pminfo^.MY0 := START_Y0;
        pminfo^.MX1 := START_X1;
        pminfo^.MY1 := START_Y1;
   ELSE pminfo^ := pmsrc^;
  END;

  pminfo^.pMBitmap := NIL;
END MINew;


PROCEDURE MIDel(pminfo :PMANDINFO);
BEGIN
  IF pminfo^.pMBitmap # NIL THEN DosFreeMem(pminfo^.pMBitmap); END;
  DEALLOCATE( pminfo, SIZE(MANDINFO) );
END MIDel;

END MI;


(**    Picture List   **)

MODULE PList;

IMPORT MANDINFO, PMANDINFO, MINew, MIDel;
FROM Storage IMPORT DEALLOCATE;

EXPORT QUALIFIED nCurPic, nPic,       (* READ-ONLY *)
                 Back, Curr, Forw,To,
                 Cut, App, Replace,
                 hzMB,
                 Quit;

CONST PnMAX = 100;

VAR   nCurPic, nPic :INTEGER;
      aPicList      :ARRAY [0..PnMAX-1] OF PMANDINFO;


PROCEDURE Back();
BEGIN
  IF nCurPic # 0 THEN  DEC(nCurPic); END;
END Back;

PROCEDURE Curr(): PMANDINFO; BEGIN RETURN aPicList[nCurPic]; END Curr;

PROCEDURE Forw();
BEGIN
  IF nCurPic+1 # nPic THEN INC(nCurPic); END;
END Forw;

PROCEDURE To(n: INTEGER); BEGIN nCurPic:=n; END To;


PROCEDURE Cut(cpos: INTEGER);

VAR i: INTEGER;

BEGIN
  (* requires 0 < cpos < nPic *)

  FOR i:=cpos TO nPic-1 DO
    MIDel(aPicList[i]);
    aPicList[i] := NIL;
  END;

  nCurPic := cpos; nPic := cpos;
  Back();
END Cut;

PROCEDURE App(pm :PMANDINFO);
BEGIN
  IF nPic=PnMAX THEN RETURN; END;
  aPicList[nPic] := pm;
  INC(nPic);
END App;

PROCEDURE Replace(n :INTEGER; p :PMANDINFO);
BEGIN
  MIDel(aPicList[n]);
  aPicList[n] := p;
END Replace;


PROCEDURE hzMB():BOOLEAN; BEGIN  RETURN aPicList[0]^.pMBitmap # NIL; END hzMB;


PROCEDURE Quit();

VAR i: INTEGER;

BEGIN
  FOR i:=0 TO nPic-1 DO
    DEALLOCATE( aPicList[i], SIZE(MANDINFO) );
  END;

END Quit;

-- Type constructor
BEGIN
  MINew(aPicList[0], NIL);
  nCurPic := 0;
  nPic   := 1;

END PList;

(*----------------------------------------------------------------------------*)


VAR ID :ARRAY [0..2000] OF LONGREAL;

(** Mandelbrodt set calculation procedure to execute in the background thread **)

PROCEDURE [O.EXPENTRY] CalcSet (c: CARDINAL);

(* these types are used only to cast rather than to instantiate *)
CONST UB  = 0ffffffH;
TYPE  PTR  = POINTER TO ARRAY [0..UB]   OF CARD8;

VAR x0, y0, x, y, x2, y2 :LONGREAL;
    wb, i, j             :CARDINAL;
    l                    :LONGREAL;
    p                    :CARDINAL;
    n                    :CARDINAL;
    pHuge                :PTR;
    pminfo               :PMANDINFO;

BEGIN

  pminfo := PMANDINFO(c); (* thread parms passed by DosCreateThread *)
  WITH pminfo^ DO
   IF pMBitmap=NIL THEN RETURN; END;

   IF Bcx>Bcy
     THEN j := Bcx;
          l := MX1-MX0;
     ELSE j := Bcy;
          l := MY1-MY0;
   END;
   FOR  i:=0 TO j DO
     ID[i] := l * LFLOAT(i) / LFLOAT(j);
   END;

   pHuge := PTR(pMBitmap);

   p    := 0;
   wb   := (Bcx + 3) / 4 * 4;
   perc := 0; prevperc := 0;
   O.WinStartTimer(hAB, hMainClient, 0, 200);

   FOR j:=1 TO Bcy DO
     y0 := MY0 + ID[j];
     FOR i:=1 TO wb DO
       y